module luna_control
  use kuty
  use suty
  implicit none
  !
  type t_shmstat
     integer key
     integer id
     integer size
     integer p
  end type t_shmstat
  !
  integer,parameter::nshm=3
  integer,parameter,public::SHMID_ENV  = 3
  integer,parameter,public::SHMID_IN   = 1
  integer,parameter,public::SHMID_OUT  = 2
  type(t_shmstat),public::shmstats(nshm)
  !
  integer,public,parameter::RSTAT_INIT         = z'00000001'
  integer,public,parameter::RSTAT_RUN          = z'00000002'
  integer,public,parameter::RSTAT_DONE         = z'00000003'
  integer,public,parameter::RSTAT_ERROR        = z'10000000'
  !
  integer,public,parameter::TCPU_USER   = 0
  integer,public,parameter::TCPU_NICE   = 1
  integer,public,parameter::TCPU_SYSTEM = 2
  integer,public,parameter::TCPU_INTR   = 3
  integer,public,parameter::TCPU_IDLE   = 4
  integer,public,parameter::TCPU_BUSY   = 5 ! 0+1+2
  integer,public,parameter::TCPU_NUM    = 6
  !
  integer,parameter::STRLENMAX=512
  integer,parameter::plogunit=999
  character*(STRLENMAX) homedir,wdir,flog,fpid,fconf,frecon
  character*(*),parameter::WD=".pemd"
  character*(*),parameter::LOGFILE="pemd.log"
  character*(*),parameter::PIDFILE="pemd.pid"
  character*(*),parameter::CONFILE="pemd.conf"
  character*(*),parameter::RECONPROG="bin/start_recon"
  integer,target::inport=3479
  integer::subnet=z'ffffffff'
  character*32,target::subnetstr="255.255.255.255"
  integer ppid ! parent pid
  type(t_shmstat) pshm(nshm) ! parent shm
  integer s2 ! socket client
  ! status flags
  integer,parameter::STF_CKSUM_SET     = z"0000000000000001"
  integer,parameter::STF_DATA_SET      = z"0000000000000002"
  integer,parameter::STF_TYPE_SET      = z"0000000000000004"
  integer,parameter::STF_RECON_START   = z"0000000000000008"
  integer,parameter::STF_RECON_RUN     = z"0000000000000010"
  integer,parameter::STF_RECON_END     = z"0000000000000020"
  integer,parameter::STF_RECON_FAILURE = z"0000000000000040"
  integer,parameter::STF_RECON_KILLED  = z"0000000000000080"
  integer,parameter::STF_IMAGE_GOT     = z"0000000000000100"
  integer,parameter::STF_SHM_ALLOCED   = z"0000000000000200"
  integer,parameter::STF_LOG_OPEN      = z"0000001000000000"
  integer,parameter::STF_PUT           = z"0000002000000000"
  integer,parameter::STF_GET           = z"0000004000000000"
  integer,parameter::STF_QUIT          = z"0000008000000000"
  integer,parameter::STF_DEBUG         = z"0000010000000000"
  integer,parameter::STF_PSHM_OPEN     = z"0000020000000000"
  integer,parameter::STF_LOG           = z"0000040000000000"
  integer,parameter::STF_INIT_MASK     = z"ffffffff00000000"
  integer,parameter::STF_USER_MASK     = not(STF_INIT_MASK)
  integer,parameter::STF_RC_PASSTHROUGH= z"8000000000000000"

  ! error codes
  integer,parameter::ERR_ILLCOM    = 1
  integer,parameter::ERR_MISARG    = 2
  integer,parameter::ERR_INVARG    = 3
  integer,parameter::ERR_RECV      = 4
  integer,parameter::ERR_SMIS      = 5
  integer,parameter::ERR_CMIS      = 6
  integer,parameter::ERR_INVCOM    = 7
  integer,parameter::ERR_D2BIG     = 8
  integer,parameter::ERR_NOMEM     = 9
  integer,parameter::ERR_RECON     = 10
  integer,parameter::ERR_NOSYS     = 11
  integer,parameter::ERR_FXIST     = 12
  integer,parameter::ERR_TRASH     = 13
  integer,parameter::ERR_NODATA    = 14
  integer,parameter::ERR_ECHO      = 15
  integer,parameter::ERR_SYSCALL   = 16
  integer,parameter::ERR_NOPROC    = 17
  integer,parameter::ERR_NOENT     = 18
  integer::pstat=STF_DEBUG ! <<<<<<<<<<<<<<<<<<<<<<<

  !
contains

  !
  subroutine proc_close
    integer is,rc
    if(s2>0) then
       call close(s2)
       s2=0
    end if
    do is=1,nshm
       if(dealloc_shm(shmstats(is))/=0) &
            call plog("proc_close: dealloc_shm: error="//trim(i2a(rc)))
    end do
  end subroutine proc_close

  !
  recursive subroutine plog(mess,notime)
    character*(*),intent(in)::mess
    logical,intent(in),optional::notime
    integer v(8)
    character*128 time,fig
    character(STRLENMAX) s
    integer istat
    if(.not.present(notime)) then
       call date_and_time(values=v)
       time="["//i2a(v(1))
       time=trim(time)//"-"//trim(i2a(v(2),2))
       time=trim(time)//"-"//trim(i2a(v(3),2))
       time=trim(time)//", "//trim(i2a(v(5),2))
       time=trim(time)//":"//trim(i2a(v(6),2))
       time=trim(time)//"."//trim(i2a(v(7),2))//"]"
    else
       time=""
    end if
    s=trim(time)//" "//trim(mess)
    if(green(STF_DEBUG)) then
       call write1(trim(time)//" "//trim(mess)//"\n")
    end if
    if(green(STF_LOG_OPEN)) then
       open(unit=plogunit,file=flog,iostat=istat,status="old",access="append")
       if(istat==0) then
          write(plogunit,*) trim(time)//" "//trim(mess)
          call flush(plogunit)
          close(plogunit)
       end if
    end if
  end subroutine plog
  !
  logical function green(code)
    integer,intent(in)::code
    if(iand(pstat,code)==0) then
       green=.false.
    else
       green=.true.
    end if
  end function green
  !
  subroutine plog_statchg(mess,olds,flg)
    character*(*),intent(in)::mess
    integer,intent(in)::olds,flg
    call plog(trim(mess)//" "//trim(i2a(flg,hex=.true.))//&
         "h ["//trim(i2a(olds,hex=.true.))//&
         "h] -> ["//trim(i2a(pstat,hex=.true.))//"h]")
  end subroutine plog_statchg
  !
  subroutine setf(flg)
    integer,intent(in)::flg
    integer olds
    olds=pstat
    if(.not.green(flg)) then
       pstat=ior(pstat,flg)
       if(green(STF_DEBUG)) call plog_statchg("Status set:",olds,flg)
    end if
  end subroutine setf
  !
  subroutine clef(flg)
    integer,intent(in)::flg
    integer olds
    olds=pstat
    if(green(flg)) then
       pstat=iand(pstat,not(flg))
       if(green(STF_DEBUG)) call plog_statchg("Status cle:",olds,flg)
    end if
  end subroutine clef
  !
  subroutine doexit(mess)
    character*(*),intent(in),optional::mess
    integer ec
    if(present(mess)) then
       call plog("EXIT due to: "//mess)
       ec=1
    else
       ec=0
    end if
    call unlink(fpid)
    if(green(STF_LOG_OPEN)) close(1)
    call exit(ec)
  end subroutine doexit
  !
  subroutine init
    integer istat
    call getlog(homedir)
    homedir="/home/"//trim(homedir)
    wdir=trim(homedir)//"/"//WD
    fpid=trim(wdir)//"/"//PIDFILE
    flog=trim(wdir)//"/"//LOGFILE
    fconf=trim(wdir)//"/"//CONFILE
    frecon=trim(homedir)//"/"//RECONPROG
    open(unit=plogunit,file=flog,iostat=istat,status="replace")
    if(istat==0) then
       call setf(STF_LOG_OPEN)
    else
       call doexit("failed to open log "//trim(flog)//", error="//trim(i2a(istat)))
    end if
    close(plogunit)
  end subroutine init
  !
  subroutine me_second_mana
    integer istat,p,i
    character(STRLENMAX) str,args
    open(unit=1,file=fconf,iostat=istat,status="old")
    if(istat/=0) return
    call plog("reading "//trim(fconf))
    i=0
    do while(istat==0)
       read(1,"(a)",iostat=istat) str
       if(istat/=0) exit
       i=i+1
       str=adjustl(str)
       if(len_trim(str)==0) cycle
       select case(str(1:1))
       case("#",";")
          cycle
       case default
          p=index(str,"=")
          if(p==0) call doexit("invalid config at line "//trim(i2a(i)))
          args=adjustl(trim(str(p+1:)))
          select case(str(1:p-1))
          case("flags")
             call me_first_mana(args)
          case("program")
             frecon=trim(args)             
          case default
             call doexit("unrecognized config keyword """//trim(str(1:p-1))//&
                  """ at line "//trim(i2a(i)))
          end select
       end select
    end do
  end subroutine me_second_mana
  !
  subroutine me_first_mana(args)
    character*(*),intent(in),optional::args ! must be adjustl-ed
    integer i,l,istat,j
    character(STRLENMAX) str
    integer,pointer::k
    character(32),pointer::s
    nullify(s,k)
    do i=1,get_narg()
       call get_arg(i,str,l)
       if(str(1:1)=="-") then
          do j=2,l
             select case(str(j:j))
             case("q")
                call clef(STF_DEBUG)
             case("v")
                call setf(STF_DEBUG)
             case("p")
                k=>inport
             case("m")
                s=>subnetstr
             case default
                call doexit("unrecognized argument: "//trim(str(j:j)))
             end select
          end do
       else
          if(associated(k)) then
             read(str(1:l),*,iostat=istat) k
             nullify(k)
          elseif(associated(s)) then
             s=str(1:l)
             if(l>sizeof(s)) call doexit("invalid option")
             nullify(s)
          end if
       end if
    end do
    if(associated(s).or.associated(k)) call doexit("missing argument")
    !
  contains
    !
    integer function get_narg()
      integer pp,ll
      get_narg=0
      if(present(args)) then
         ll=len_trim(args)
         if(ll==0) return
         do pp=1,ll
            if(args(pp:pp)==" ") get_narg=get_narg+1
         end do
         get_narg=get_narg+1
      else
         get_narg=command_argument_count()
      end if
    end function get_narg
    !
    subroutine get_arg(i,oarg,l)
      integer,intent(in)::i
      character*(*),intent(out)::oarg
      integer,intent(out)::l
      integer p,n,p1,p2,ll
      n=0
      oarg=""
      l=0
      p1=0
      if(present(args)) then
         ll=len_trim(args)
         if(ll==0) return
         if(i/=1) then
            do p=1,ll
               if(args(p:p)==" ") then
                  p1=p
                  n=n+1
                  if(n>=i-1) exit
               end if
            end do
         end if
         p2=index(args(p1+1:)," ")
         if(p2==0) then
            p2=ll
         else
            p2=p2+p1
         end if
         oarg=args(p1+1:p2-1)
         l=p2-1-(p1+1)+1
      else
         call get_command_argument(i,oarg,l)
      end if
    end subroutine get_arg
  end subroutine me_first_mana

  !
  integer function dealloc_shm(shmstat)
    type(t_shmstat),intent(inout)::shmstat
    dealloc_shm=0
    if(shmstat%p/=0) then
       call plog("dealloc_shm: id="//trim(i2a(shmstat%id))//&
            ", key="//trim(i2a(shmstat%key)))
       if(shmdt(shmstat%p)==-1) then
          dealloc_shm=-geterrnoa()
          call plog("dealloc_shm: shmdt: p="//trim(i2a(shmstat%p))//&
               ", error="//trim(i2a(dealloc_shm)))
          return
       end if
       shmstat%p=0
       if(shmctl(shmstat%id,IPC_RMID,0)==-1) then
          dealloc_shm=-geterrnoa()
          call plog("dealloc_shm: shmctl: error="//trim(i2a(dealloc_shm)))
          return 
       end if
       shmstat%id=0
       shmstat%key=0
    end if
  end function dealloc_shm

  !
  integer function alloc_shm(shmstat,id,pid,sz)
    type(t_shmstat),intent(inout)::shmstat
    integer,intent(in)::pid,id
    integer,intent(in),optional::sz
    integer flg,s,aid,key,p
    alloc_shm=0
    !
    if(shmstat%p/=0) then
       alloc_shm=dealloc_shm(shmstat)   
       if(alloc_shm/=0) return
    end if
    !
!    key=ftok(wdir,ior(ishft(id,24),pid)) ! <<<<<<<<<<<
    key=ftokwpid(wdir,id,pid)
    if(green(STF_DEBUG)) call plog("alloc_shm: ftok: "//trim(wdir)&
         //", id="//trim(i2a(id))//", pid="//trim(i2a(pid))//", key="//trim(i2a(key)))
    if(key==-1) return
    shmstat%key=key
    !
    if(present(sz)) then
       s=sz
    else
       s=SHMSZ
    end if
    !
    aid=shmget(shmstat%key,s,ior(IPC_CREAT,o'0666'))
    if(aid<=0) then
       alloc_shm=-geterrnoa()
       call plog("alloc_shm: shmget: "//trim(i2a(alloc_shm)))
       return
    end if
    shmstat%id=aid
    if(green(STF_DEBUG)) call plog("alloc_shm: shmget: id="//trim(i2a(aid)))
    p=shmat(shmstat%id,0,0)
    if(p<=0) then
       alloc_shm=-geterrnoa()
       call plog("alloc_shm: shmat: error="//trim(i2a(alloc_shm)))
       return
    end if
    shmstat%size=s
    shmstat%p=p
  end function alloc_shm
end module luna_control
!
program pemd
  use luna_control
  use kuty
  use suty
  implicit none
  integer s,n
  character*(STRLENMAX) mess,retstr,com,arg,str
  integer lencom,lenarg,lenmess
  integer istat,rc
  character*256 cksum
  integer dsize,isize
  integer dtype,dtlo,dtup
  integer cktype 
  character*256 recon_args,recon_args_s
  integer rpid ! pid of recon

  ! data types
  integer,parameter::DT_LISTMODE  = z"00000000"
  integer,parameter::DT_HISTOGRAM = z"00000001"
  integer,parameter::DT_IMAGE     = z"00000002"
  integer,parameter::DT_MAX       = z"00000002"

  ! data sub types
  integer,parameter::DTS_SCAN     = z"00000000"
  integer,parameter::DTS_CALIB    = z"00000001"
  integer,parameter::DTS_NORM     = z"00000002"
  integer,parameter::DTS_APPEND   = z"00000004"
  integer,parameter::DTS_MAX      = z"00000004"

  integer pid,mpid
  integer exit_code

  integer*1,allocatable::logbuf(:)
  integer logsize

  !
  call init
  !
  open(unit=1,file=fpid,iostat=istat,status="unknown")
  if(istat/=0) call doexit("already running?")
  ppid=getpid()
  mpid=ppid
  call plog("started pid="//trim(i2a(ppid)))
  write(1,*) trim(i2a(ppid))
  close(1)
  !
  call me_first_mana
  call me_second_mana
  !
  subnet=a2i_mask(subnetstr)
  if(subnet==0) call doexit("unrecognized subnet")
  subnetstr=i2a_mask(subnet)

  if(green(STF_DEBUG)) then
     call plog("port="//trim(i2a(inport)),.true.)
     call plog("subnet="//trim(subnetstr),.true.)
     call plog("program="//trim(frecon),.true.)
  end if
  !
  call setport(inport)
  call setsubnet(subnet)
  !
  s=opentcp(inport)
  if(s<=0) then
     call doexit("opentcp failed: error="//trim(i2a(geterrnoc())))
     stop
  end if
  !
  call msets(loc(shmstats),0,sizeof(shmstats))
  !
  call setup_SIGCHLD
  if(alloc_shm(shmstats(SHMID_ENV),SHMID_ENV,ppid,4096)/=0) &
       call doexit("failed to alloc master mem")
  call setf(STF_PSHM_OPEN)

  s2=0
  call setup_SIGTERM(loc(proc_close)) !<<<<<<<<<<<<<<<<<<<<<<<<<<<
  main: do
     if(green(STF_DEBUG)) call plog("Waiting for a connection...")
     s2=listenaccept(s)
     str=""
     call getipstr(loc(str))
     if(s2<=0) then
        call plog("Connection refused: "//trim(str))
        cycle
     else
        if(green(STF_DEBUG)) call plog("Connected: "//trim(str))
     end if
     pid=fork()
     if(pid==0) then
        call setup_SIGTERM(loc(proc_close))
        mpid=getpid()
        call mcps(loc(pshm),loc(shmstats),sizeof(shmstats)) ! for parent
        call msets(loc(shmstats),0,sizeof(shmstats))        ! clear child 
        call plog("session opened pid="//trim(i2a(mpid)))
        call proc_mess(exit_code)
        call proc_close
        call plog("session closed.")
        if(green(STF_QUIT)) call proc_quit
        call exit(exit_code)
     else if(pid>0) then        
        call close(s2)
        s2=0
     else
        call doexit("fork failed.")
     end if
  end do main
  !
contains
 
  !
  subroutine proc_quit
    call close(s)
    call unlink(fpid)
    rc=kill(0,SIGTERM) ! all child and me
    call clef(STF_LOG_OPEN)
  end subroutine proc_quit

  !
  subroutine proc_mess(ec)
    integer,intent(out)::ec
    integer errcount,etime
    integer,parameter::MAXERRCOUNT=3
    integer,parameter::MINERRTIME=MAXERRCOUNT
    errcount=0
    dtype=0
    cksum=""
    rc=0
    etime=0
    do 
       ec=0
       if(green(STF_DEBUG)) call plog("Waiting for a message...")
       lenmess=recv(s2,loc(mess))
       if(lenmess<=0) then
          ec=ERR_INVCOM
          exit
       end if
       lenmess=len_mess(mess,lenmess)
       call mess2com(mess(1:lenmess),com,arg)
       lencom=len_trim(com)
       if(lencom==0) cycle
       lenarg=len_trim(arg)
       if(green(STF_DEBUG)) then
          call plog("GOT ["//trim(i2a(lenmess))//"]: "//trim(mess(1:lenmess)))
          call plog("arg: "//trim(arg))
       end if
       if(errcount>0) errcount=errcount-1
       select case(com(1:lencom))
       case("pause")
          call fnc_kill(SIGSTOP)
       case("resume")
          call fnc_kill(SIGCONT)
       case("init")
          call fnc_init
       case("exit")
          exit
       case("quit")
          call setf(STF_QUIT)
          exit
       case("type")
          call fnc_type
       case("checksum")
          call fnc_checksum
       case("put")
          call fnc_put1
       case("args")
          rc=ERR_MISARG
          if(lenarg/=0) then
             rc=0
             recon_args=arg(1:lenarg)
          end if
       case("begin")
          call fnc_begin
       case("stop")
          call fnc_kill(SIGKILL)
       case("status")
          call fnc_status
       case("strerror")
          call fnc_strerror
       case("cpu")
          call fnc_cpu
       case("save")
          rc=ERR_NOSYS
       case("getlog")
          call fnc_log1
       case("get")
          call fnc_get1
       case default
          rc=ERR_INVCOM
          if(errcount==0) etime=timec()
          errcount=errcount+2
          if(errcount>MAXERRCOUNT) then
             etime=timec()-etime
             if(etime<MINERRTIME) then
                call plog(trim(i2a(errcount-1))//" invalid coms in "//&
                     trim(i2a(etime))//" sec!")
                ec=ERR_TRASH
                exit
             end if
             errcount=0
          end if
       end select
       ec=ERR_ECHO
       if(.not.echo()) exit
       ! 
       if(green(STF_PUT)) then
          call fnc_put2
          call clef(STF_PUT)
       else if(green(STF_GET)) then
          call fnc_get2
          call clef(STF_GET)
          cycle
       else if(green(STF_LOG)) then
          call fnc_log2
          call clef(STF_LOG)
          cycle
       else
          cycle
       end if
       if(.not.echo()) exit 
    end do 
  end subroutine proc_mess
  !
  logical function echo()

    if(.not.green(STF_RC_PASSTHROUGH)) then
       write(retstr,*) rc
       retstr=adjustl(retstr)
    else
       call clef(STF_RC_PASSTHROUGH)
    end if
    if(green(STF_DEBUG)) call plog("REPLY: "//trim(retstr))
    if(send(s2,loc(retstr),len_trim(retstr))>0) then
       echo=.true.
    else
       echo=.false.
       call plog("echo: failed error="//trim(i2a(geterrnoc())))
    end if
  end function echo
  !
  integer function len_mess(mess,max_len)
    character*(*),intent(in)::mess
    integer,intent(in)::max_len
    integer ii
    len_mess=0
    do ii=max_len,1,-1
       if(ichar(mess(ii:ii))>32) then
          len_mess=ii
          exit
       end if
    end do    
  end function len_mess
  !
  subroutine mess2com(mess,c,a)
    character*(*),intent(in)::mess
    character*(*),intent(out)::c,a
    integer ii
    c=adjustl(mess)
    ii=len_trim(c)
    if(ii==0) return
    ii=index(trim(c)," ")
    if(ii==0) then
       a=""
    else
       a=c(ii+1:)
       c=c(1:ii-1)
    end if
  end subroutine mess2com
  !
  subroutine fnc_init
    integer id
    integer qw
    pointer(pqw,qw)
    recon_args=""
    dtype=0
    cksum=""
    pstat=iand(pstat,STF_INIT_MASK)
    rpid=0
    rc=ERR_NOMEM
    do id=1,nshm
       if(alloc_shm(shmstats(id),id,mpid)/=0) return
       pqw=shmstats(id)%p
       qw=0
    end do
    call setf(STF_SHM_ALLOCED)
    rc=0
  end subroutine fnc_init
  !
  subroutine fnc_checksum
    integer ii
    call clef(STF_CKSUM_SET)
    call clef(STF_DATA_SET)

    rc=ERR_MISARG
    if(lenarg==0) return

    call lower(arg)
    ii=index(arg," ")
    if(ii==0) then
       rc=ERR_MISARG
       return
    end if
    select case(arg(1:ii-1))
    case("md5")
       cktype=CKT_MD5
    case("sha1")
       cktype=CKT_SHA1
    case("sha256")
       cktype=CKT_SHA256
    case default
       rc=ERR_INVARG
       return
    end select
    cksum=trim(arg(ii+1:))
    if(len_trim(cksum)==0) then
       rc=ERR_MISARG
       return
    end if
    if(green(STF_DEBUG)) call plog("cksum: cktype="//trim(i2a(cktype))&
         //", "//trim(cksum))
    rc=0
    call setf(STF_CKSUM_SET)
  end subroutine fnc_checksum


  subroutine fnc_kill(sig)
    integer,intent(in)::sig
    if(green(STF_RECON_RUN).and.rpid>0) then
       rc=kill(rpid,sig)
       if(rc/=0) then
          call plog("fnc_kill: kill: error="//trim(i2a(geterrnoa())))
          rc=ERR_SYSCALL
       end if
    else
       rc=ERR_NOPROC
    end if
  end subroutine fnc_kill

  !
  subroutine fnc_cpu
    integer cpuarg

    rc=ERR_INVARG
    if(lenarg==0) arg="all"
    select case(arg)
    case("user")
       cpuarg=TCPU_USER
    case("nice")
       cpuarg=TCPU_NICE
    case("sys")
       cpuarg=TCPU_SYSTEM
    case("intr")
       cpuarg=TCPU_INTR
    case("idle")
       cpuarg=TCPU_IDLE
    case("busy")
       cpuarg=TCPU_BUSY
    case("all")
       cpuarg=loc(retstr)
       call setf(STF_RC_PASSTHROUGH)
    case("vnumc")
       cpuarg=TCPU_NUM
    case default
       return
    end select
    
    rc=cpu(cpuarg)
    if(rc<0) then
       rc=ERR_SYSCALL
    else
       if(arg=="all") retstr(rc+1:)=""
       write(*,*) trim(retstr)
    end if

  end subroutine fnc_cpu

  !
  subroutine fnc_type
    call clef(STF_DATA_SET)
    call clef(STF_TYPE_SET)

    rc=ERR_MISARG
    if(lenarg==0) return

    rc=ERR_INVARG
    read(arg,"(Z16)",iostat=istat) dtype
    if(istat/=0) return
    dtlo=iand(dtype,z"ffff")
    if(dtlo>DT_MAX) return
    dtup=ishft(iand(dtype,z"ffff0000"),-16)
    if(dtup>DTS_MAX) return
    
    select case(dtlo)
    case(DT_HISTOGRAM,DT_IMAGE)
       rc=ERR_NOSYS
       return
    end select

    if(iand(dtup,3)/=0) then
       rc=ERR_NOSYS
       return
    end if
    if(iand(dtup,DTS_APPEND)/=0) then
       rc=ERR_NOSYS
       return
    end if

    rc=0
    if(green(STF_DEBUG)) call plog("Data type set: "//i2a(dtype,hex=.true.))
    call setf(STF_TYPE_SET)
  end subroutine fnc_type

  subroutine fnc_put1
    rc=ERR_ILLCOM
    if(.not.green(STF_CKSUM_SET)) return
    if(.not.green(STF_TYPE_SET)) return
    if(.not.green(STF_SHM_ALLOCED)) return

    rc=ERR_MISARG
    if(lenarg==0) return
    
    rc=ERR_INVARG
    read(arg(1:lenarg),*,iostat=istat) dsize
    if(istat/=0.or.dsize<=0) return
    if(green(STF_DEBUG)) call plog("put: datasize="//trim(i2a(dsize)))
    if(dsize>shmstats(SHMID_IN)%size) then
       rc=ERR_D2BIG
       return
    end if
    rc=0
    call setf(STF_PUT)
  end subroutine fnc_put1
  !  
  subroutine fnc_put2
    use suty
    integer*1 buf(*)
    pointer(pbuf,buf)
    !
    call clef(STF_DATA_SET)
    !
    pbuf=shmstats(1)%p
    call mcps(pbuf,loc(dsize),8)
    pbuf=pbuf+8
    n=recvdata(s2,pbuf,dsize)
    if(n<0) then
       rc=-geterrnoc()
       return
    end if
    !   
    rc=ERR_SMIS
    if(n/=dsize) return
    !
    rc=ERR_CMIS
    str=get_cksum(cktype,dsize,buf)
    if(green(STF_DEBUG)) call plog("put: checksum="//trim(str))
    if(trim(str)/=trim(cksum)) return
    !
    rc=0
    call setf(STF_DATA_SET)
  end subroutine fnc_put2

  !
  subroutine fnc_log1()
    integer ii
    character*(STRLENMAX) file
    integer sbuf(13)
    !
    ! error must be negative
    rc=-ERR_MISARG
    if(lenarg==0) return
    call lower(arg)

    ii=index(arg," ")
    if(ii==0) then
       rc=-ERR_MISARG
       return
    end if
    select case(arg(1:ii-1))
    case("recon")
       file="/home/joker/recon_start.log"
    case("server")
       file=flog
    case default
       rc=-ERR_INVARG
       return
    end select

    open(unit=1,file=file,status="old",access="stream")
    if(istat/=0) then
       call plog("fnc_log1: open failed: file="//&
            trim(file)//", istat="//trim(i2a(istat)))
       rc=-ERR_NOENT
       return
    end if

    select case(trim(arg(ii+1:)))
    case("text")
       if(logsize>0) then
          if(allocated(logbuf)) deallocate(logbuf)
          allocate(logbuf(logsize))
          read(1,iostat=istat) logbuf
          if(istat==0) then
             call setf(STF_LOG)
             rc=0
          else
             deallocate(logbuf)
             rc=-ERR_SYSCALL
          end if
       else
          rc=-ERR_NODATA
       end if
    case("size")
       call fstat(1,sbuf,istat)
       if(istat/=0) then
          rc=-ERR_SYSCALL
          close(1)
          return
       end if
       logsize=sbuf(8)
       rc=logsize
    case default
       rc=-ERR_INVARG
       return
    end select
    close(1)
    if(green(STF_DEBUG)) call plog("fnc_log1: file="//trim(flog)//&
         ", size="//trim(i2a(logsize)))
  end subroutine fnc_log1

  !
  subroutine fnc_log2
    if(allocated(logbuf)) then
       if(green(STF_DEBUG)) call plog("fnc_log2: begin: size="//trim(i2a(logsize)))
       if(send(s2,loc(logbuf),logsize)<=0) &
            call plog("fnc_log2: send failed, error"//trim(i2a(geterrnoc())))
    else
       call plog("fnc_log2: logbuf not allocated!")
    end if
  end subroutine fnc_log2
  
  !
  subroutine fnc_get1()
    integer*1 buf(*)
    pointer(pbuf,buf)
    !
    ! error must be negative
    rc=-ERR_ILLCOM
    if(.not.green(STF_IMAGE_GOT)) return

    rc=-ERR_MISARG
    if(lenarg==0) return
    
    call lower(arg)
    select case(arg(1:lenarg))
    case("size")
       ! retrieve img size from shm
       rc=isize
       if(rc>0) call setf(STF_IMAGE_GOT)
    case("cksum")
       call setf(STF_RC_PASSTHROUGH)
       pbuf=shmstats(SHMID_OUT)%p
       retstr=get_cksum(cktype,isize,buf)
    case("image")
       rc=0
       call setf(STF_GET)
    case default
       rc=-ERR_INVARG
    end select
  end subroutine fnc_get1
  !
  subroutine fnc_get2
    if(send(s2,shmstats(SHMID_OUT)%p,isize)<=0) &
         call plog("fnc_get2: send failed, error"//trim(i2a(geterrnoc())))
  end subroutine fnc_get2
  !
  subroutine fnc_begin
    call clef(STF_RECON_START)
    call clef(STF_RECON_END)
    call clef(STF_RECON_RUN)
    call clef(STF_RECON_FAILURE)
    call clef(STF_RECON_KILLED)
    call msets(shmstats(SHMID_ENV)%p,0,shmstats(SHMID_ENV)%size)
    if(access(trim(frecon),"x")==0) then
       recon_args_s="-M "//trim(wdir)//" -p "//trim(i2a(mpid))
       if(dtlo==DT_LISTMODE) call strapp(recon_args_s,"-l")
       com=trim(frecon)
       call strapp(com,trim(recon_args))
       call strapp(com,trim(recon_args_s))
       call strapp(com,"&")
       rc=system(com)           
       if(rc/=0) then
          call plog(trim(com)//" returned "//trim(i2a(rc)))
          rc=ERR_RECON
       else
          if(green(STF_DEBUG)) call plog("START: "//trim(com))
          call setf(STF_RECON_START)
       end if
    else
       call plog("fnc_begin: no such executable: "//trim(frecon))
       rc=ERR_RECON       
    end if
  end subroutine fnc_begin
  !
  subroutine fnc_status
    integer q,rpid
    pointer(p,q)
    if(green(STF_RECON_START)) then
       p=shmstats(SHMID_ENV)%p 
       rpid=q
       if(rpid>0) then
          if(isRunning(rpid)>0) then
             if(green(STF_DEBUG)) call plog("recon pid="//trim(i2a(rpid))//" running.")
             call setf(STF_RECON_RUN)
          else
             if(green(STF_DEBUG)) call plog("recon pid="//trim(i2a(rpid))//" not running.")
             call setf(STF_RECON_END)
             call clef(STF_RECON_RUN)
             call clef(STF_RECON_START)
          end if
       end if
       if(green(STF_RECON_END)) then
          p=p+8
          select case(q)
          case(RSTAT_DONE)
             p=shmstats(SHMID_OUT)%p
             if(q>0) then
                isize=q
                call setf(STF_IMAGE_GOT)
             else
                call setf(STF_RECON_FAILURE)             
             end if
             if(green(STF_DEBUG)) &
                  call plog("fnc_status: RSTAT_DONE detected with image size="//trim(i2a(q)))
          case(RSTAT_ERROR)
             call setf(STF_RECON_FAILURE)
             call plog("fnc_status: RSTAT_ERROR detected")
          case default
             call setf(STF_RECON_KILLED)
             call plog("fnc_status: RECON_KILLED detected, rstat="//trim(i2a(q)))
          end select
       end if
    end if
    retstr=i2a(pstat,hex=.true.)
    call setf(STF_RC_PASSTHROUGH)
  end subroutine fnc_status
  !
  integer function a2i_mask(mask)
    character*(*),intent(in)::mask
    integer p1,p2,len,w,m,p3
    integer i
    p1=0
    p3=0
    p3=index(mask,"/") 
    if(p3/=0) then
       len=p3-1
    else
       len=len_trim(mask)
    end if
    a2i_mask=0
    m=0
    do i=1,4
       p2=index(mask(p1+1:),".")
       if(p2<=0) then
          p2=len+1
       else
          p2=p2+p1
       end if
       read(mask(p1+1:p2-1),*,iostat=istat) w
       if(istat/=0) return
       if(w>255) return
       m=m+ishft(w,(4-i)*8)
       p1=p2
    end do
    if(p3>0) then
       read(mask(p3+1:),*,iostat=istat) i
       if(istat/=0) return
       if(i>24) return
       i=32-i
       w=-1
       m=ior(m,not(ishft(ishft(w,-i),i)))
    end if
    a2i_mask=m
  end function a2i_mask
  !
  character*32 function i2a_mask(isub)
    integer,intent(in)::isub
    integer w
    character*32 fig
    w=ishft(iand(isub,z'ff000000'),-24)
    write(fig,*) w
    i2a_mask=adjustl(fig)
    w=ishft(iand(isub,z'ff0000'),-16)
    write(fig,*) w
    i2a_mask=trim(i2a_mask)//"."//adjustl(fig)
    w=ishft(iand(isub,z'ff00'),-8)
    write(fig,*) w
    i2a_mask=trim(i2a_mask)//"."//adjustl(fig)
    w=iand(isub,z'ff')
    write(fig,*) w
    i2a_mask=trim(i2a_mask)//"."//adjustl(fig)
  end function i2a_mask

  !
  subroutine fnc_strerror
    integer errno

    if(lenarg/=0) then
       read(arg,*,iostat=istat) errno
       if(istat/=0) errno=-1
    else
       errno=-1
    end if

    call setf(STF_RC_PASSTHROUGH)
    select case(errno)
    case(ERR_ILLCOM)
       retstr="illigal command for current status"
    case(ERR_MISARG)
       retstr="too few arguments"
    case(ERR_INVARG)
       retstr="argument not recognized"
    case(ERR_RECV)   
       retstr="error during receive"
    case(ERR_SMIS)   
       retstr="size mismatch"
    case(ERR_CMIS)   
       retstr="checksum mismatch"
    case(ERR_INVCOM)
       retstr="command not recognized"
    case(ERR_D2BIG)  
       retstr="size too big"
    case(ERR_NOMEM)  
       retstr="cannot allocate memory"
    case(ERR_RECON)  
       retstr="reconstruction failed to start"
    case(ERR_NOSYS)  
       retstr="function not implemented yet"
    case(ERR_FXIST)  
       retstr="file already exists"
    case(ERR_TRASH)  
       retstr="too many invalid command"
    case(ERR_NODATA) 
       retstr="no such data"
    case(ERR_ECHO)   
       retstr="failed to send reply"
    case(ERR_SYSCALL)
       retstr="error during system call"
    case(ERR_NOPROC)
       retstr="no such process"
    case(ERR_NOENT)
       retstr="no such file or directory"
    case default
       retstr=""
       return
    end select
  end subroutine fnc_strerror

  !
end program pemd
